;;;; 2007-05-03 22:40:20
;;;; This is your lisp file. May it serve you well.



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Jobs are a list of times for each machine                  ;
; Job set is a list of all the jobs                          ;
; Schedules are a set of job numbers in processing order     ;
; Genetic Schedules will transform into schedules            ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Machines have a queue of jobs waiting and an active item   ;
; Event queue maintains a list of all active items and       ;
;   removes and processes the next one to complete           ;
;                                                            ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                      JOB                               ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Jobs are a list of times for each machine                  ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass job ()
  ((due 
     :initarg :due
     :initform 0
     :accessor job-due )
  (times 
     :initarg :times
     :initform nil
     :accessor job-times)
  (completed
     :initarg :completed
     :initform nil
     :accessor job-completed)))

(defun make-job (due machines)
  (make-instance 'job :due due :times (make-array machines)))

(defmethod get-time ((j job) n)
  (aref (job-times j) n))

(defmethod sum-times ((j job))
  (let ((sum 0))
    (dotimes (i (array-total-size (job-times j)))
      (setf sum (+ sum (aref (job-times j) i))))
    sum))

(defmethod set-time ((j job) n val)
  (setf (aref (job-times j) n) val))

;; If completed returns the tardiness, nil if incomplete
(defmethod get-tardiness ((j job))
  (if (null (job-completed j))
      nil
      (let ((lateness (- (job-completed j) (job-due j))))
        (if (> lateness 0)
            lateness
            0))))

;; Sum tardiness of a list of jobs
(defun sum-tardiness (jobs)
  (let ((result 0))
    (dolist (j jobs)
      (setf result (+ result (get-tardiness j))))
    result))

;; If completed returns the lateness, nil if incomplete
(defmethod get-lateness ((j job))
  (if (null (job-completed j))
      nil
      (- (job-completed j) (job-due j))))

(defun sum-lateness (jobs)
  (let ((result 0))
    (dolist (j jobs)
      (setf result (+ result (get-lateness j))))
    result))

(defmethod print-object ((j job) stream)
  (format stream "{~a:" (job-due j))
  (dotimes (i (array-total-size (job-times j)))
    (format stream " ~a" (aref (job-times j) i)))
  (format stream ": ~a}" (job-completed j)))


;; Makes a list of n jobs
;; count - number of processes for the job to go through
;; proc-func - A function for generating the process times
;; due-func - A function for generating the due times
(defun make-func-jobs (n count proc-func due-func)
  (let ((jobs nil)
        (j nil))
    (dotimes (i n)
      (setf j (make-job (funcall due-func) count))
      (dotimes (k count)
        (set-time j k (funcall proc-func)))
      (setf jobs (cons j jobs)))
    jobs))

;; Makes a list of n jobs
;; count - number of processes for the job to go through
;; proc-func - A function for generating the process times
;; due-func - A function for generating the due times
(defun make-jobs (n count proc due)
  (let ((jobs nil)
        (j nil))
    (dotimes (i n)
      (setf j (make-job due count))
      (dotimes (k count)
        (set-time j k proc))
      (setf jobs (cons j jobs)))
    jobs))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;               JOB SCHEDULING ORDERINGS                ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; A set of normal strategies for scheduling                 ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun edd-ordering (jobs)
  (let ((result (copy-list jobs)))
    (sort result #'(lambda (a b) 
                     (< (job-due a) (job-due b))))))

(defun sjf-ordering (jobs)
  (let ((result (copy-list jobs)))
    (sort result #'(lambda (a b)
                     (< (sum-times a) (sum-times b))))))

(defun arb-ordering (jobs ordering)
  (let ((result nil))
    (dolist (o ordering)
      (setf result (cons (nth o jobs) result)))
    (reverse result)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                      EVENT                             ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Used for the event queue of all the machines and jobs in   ;
;   them                                                     ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass event ()
  ((time
     :initarg :time
     :initform 0
     :accessor event-time)
   (machine
     :initarg :machine
     :initform nil
     :accessor event-machine)
   (job
     :initarg :job
     :initform nil
     :accessor event-job)))

;; Processes the current event
(defun process-event (e current-time)
  (complete (event-machine e) current-time ))

(defmethod less-event ((e1 event) (e2 event))
  (< (event-time e1) (event-time e2)))

(defmethod print-object ((e event) stream)
  (format stream "Time: ~a~%Machine: ~a~%Job: ~a" (event-time e) (event-machine e) (event-job e)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                     MACHINE                            ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Machines have a queue of jobs waiting and an active item   ;
; Event queue maintains a list of all active items and       ;
;   removes and processes the next one to complete           ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass machine ()
  ((queue
     :initarg :queue
     :initform nil
     :accessor machine-queue)
   (active
     :initarg :active
     :initform nil
     :accessor machine-active)
   (key
     :initarg :key
     :initform nil
     :accessor machine-key)
   (next
     :initarg :next
     :initform nil
     :accessor machine-next)))

(defmethod print-object ((m machine) stream)
  (format stream "Machine: ~a  Active: ~a  Queued: ~a" (machine-key m) (machine-active m) (length (machine-queue m))))

;; Removes the current active item and puts a new one from the queue 
;; Sends the job to the next machine
;; Returns a list of new events  made
(defmethod complete ((m machine) current-time)
  (let ((next-event (recieve (machine-next m) (machine-active m) current-time)))
    ;(format t "~a: ~a completed: ~a~%" current-time (machine-key m) (machine-active m))
    (setf (machine-active m) (car (machine-queue m)))
    (setf (machine-queue m) (cdr (machine-queue m)))
    (cons (make-active-event m current-time) next-event)))

;; Returns a new event that is made with the active item if it exists
(defmethod make-active-event ((m machine) current-time)
  (declare (special free-events))
  (if (not (null (machine-active m)))
      (if (null free-events)
          (make-instance 'event
                         :time (+ current-time (get-time (machine-active m) (machine-key m)))
                         :machine m
                         :job (machine-active m))
          (let ((result (car free-events)))
            ;(format t "Using existing event")
            (setf free-events (cdr free-events))
            (setf (event-time result) (+ current-time (get-time (machine-active m) (machine-key m))))
            (setf (event-machine result) m)
            (setf (event-job result) (machine-active m))
            result)) ;)
      nil))

;; Adds a job to the queue or begins processing
;; Returns an event if a new one is created from the receptions
(defmethod recieve ((m machine) (j job) current-time)
  ;(format t "~a: ~a recieved: ~a~%" current-time (machine-key m) j)
  (if (not (null j))
      (if (null (machine-active m))
          (progn
            ;(format t "~a: ~a setting active: ~a~%" current-time (machine-key m) j)
            (setf (machine-active m) j)
            (list (make-active-event m current-time)))
          (progn
            ;(format t "~a: ~a Adding to queue: ~a~%" current-time (machine-key m) j)
            (setf (machine-queue m) (append (machine-queue m) (list j)))
            nil))
      nil))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                        END                             ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Recieves jobs and calculates and stores their tardiness    ;
; Stores jobs that have been completed                       ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass end ()
  ((jobs
     :initarg :jobs
     :initform nil
     :accessor end-jobs)))

;; Recieves the job and sets its completed time
(defmethod recieve ((e end) (j job) current-time)
  ;(format t "~a: End recieved: ~a~%" current-time j)
  (setf (job-completed j) current-time)
  (setf (end-jobs e) (append (end-jobs e) (list j)))
  nil)

(defmethod print-object ((e end) stream)
  (format stream "End Jobs: ~a" (end-jobs e)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                 SYSTEM PROCESSING                      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Makes n machines and an end in serial order
(defun make-serial-machines (n)
  (let ((machines (list (make-instance 'end))))
    (dotimes (i n)
      (setf machines (cons (make-instance 'machine :key (- n i 1) :next (car machines))
                           machines)))
    machines))



;; Runs a list of jobs through the system
;; Returns the time to completion
(defun run-jobs (jobs machines &optional (event-queue (create-heap 'less-event)))
  (let ((new-events nil)
        (current-event)
        (current-time 0))
;        (free-events nil))
    (declare (special free-events))
    (setf free-events nil)
    (heap-clear event-queue)
    (dolist (j jobs)
      ;(format t "Queing job: ~a~%" j)
      (setf new-events (recieve (car machines) j 0))
      (dolist (e new-events)
        ;(format t "Adding event: ~a~%" e)
        (heap-insert event-queue e)))
    ;(format t "Heap top: ~a~%" (heap-peek event-queue))
    (do () ((null (setf current-event (heap-remove event-queue))))
      ;(format t "Processing Event: ~a~%" current-event)
      (setf current-time (event-time current-event))
      (setf new-events (process-event current-event current-time))
      (setf free-events (cons current-event free-events))
      ;(format t "Added ~a to free-events: ~a" current-event (length free-events))
      (dolist (e new-events)
        (heap-insert event-queue e)))
    jobs))
      
(defun test-basics (jobs machines)
  (run-jobs jobs machines)
  (format t "FIFO~%  Tardiness: ~a~%  Lateness: ~a~%" (sum-tardiness jobs) (sum-lateness jobs))
  (let ((edd-jobs (edd-ordering (copy-list jobs))))
    (run-jobs edd-jobs machines)
    (format t "EDD~%  Tardiness: ~a~%  Lateness: ~a~%" (sum-tardiness edd-jobs) (sum-lateness edd-jobs)))
  (let ((sjf-jobs (sjf-ordering (copy-list jobs))))
    (run-jobs sjf-jobs machines)
    (format t "SJF~%  Tardiness: ~a~%  Lateness: ~a~%" (sum-tardiness sjf-jobs) (sum-lateness sjf-jobs))))
#|
SIMPLE TESTING
(setf jobs (make-jobs 10 4 1 10))
(setf machines (make-serial-machines 4))
(run-jobs jobs machines)

RANDOM TESTING
(setf jobs (make-func-jobs 10 4 #'(lambda () (random 10)) #'(lambda () (random 100))))
(setf machines (make-serial-machines 4))

; FIFO
(run-jobs jobs machines)
(format t "FIFO~%  Tardiness: ~a~%  Lateness: ~a~%" (sum-tardiness jobs) (sum-lateness jobs))

; EDD
(setf edd-jobs (edd-ordering (copy-list jobs)))
(run-jobs edd-jobs machines)
(format t "EDD~%  Tardiness: ~a~%  Lateness: ~a~%" (sum-tardiness edd-jobs) (sum-lateness edd-jobs))

; SJF
(setf sjf-jobs (sjf-ordering (copy-list jobs)))
(run-jobs sjf-jobs machines)
(format t "SJF~%  Tardiness: ~a~%  Lateness: ~a~%" (sum-tardiness sjf-jobs) (sum-lateness sjf-jobs))

|#
  
